home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / paslib.arc / ACC.INC next >
Encoding:
Text File  |  1985-10-12  |  5.7 KB  |  153 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*                                                                          *)
  3. (* Written by Laszlo S. Gonc for Turbo Version 3.0                          *)
  4. (*                                                                          *)
  5. (* Can be contacted via Gene Plantz IBBS                                    *)
  6. (*                      (312) 885-9557 or  (312) 882-4227                   *)
  7. (*                                                                          *)
  8. (* The ACCEPT procedure is a variation on the readln command in Turbo       *)
  9. (* Pascal. The main ACCEPT routine uses the following sub-procedures:       *)
  10. (*                   -- cursorOn                                            *)
  11. (*                   -- cursorOff                                           *)
  12. (*                   -- get (ch)                                            *)
  13. (* The procedure allows the programmer to accept certain characters as      *)
  14. (* input at (row,column) for a specified length and exits the procedure     *)
  15. (* if [ESC] was pressed and returns true for the esc boolean value. The     *)
  16. (* type of data entered is determined by the case statement for the         *)
  17. (* datatype of the input.                                                   *)
  18. (*                                                                          *)
  19. (* For example, accept (3,1,10,1,string,esc) will accept input at row 3,    *)
  20. (* column 1, length is 10 characters, datatype 1 is defined by the case     *)
  21. (* statement, variable string and if esc was not pressed then esc = false.  *)
  22. (* A default can be used if string is predefined; otherwise let string=''   *)
  23. (* before using accept.                                                     *)
  24. (*                                                                          *)
  25. (* If you find this routine of any use, please let me know. Also, if you    *)
  26. (* make any major changes to the code or program logic, please let me       *)
  27. (* know, I am greatly interested in improvements to my routine.             *)
  28. (*                                                                          *)
  29. (*--------------------------------------------------------------------------*)
  30.  
  31. type regPack = record case integer of
  32.                 1 : (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: integer);
  33.                 2 : (AL,AH,BL,BH,CL,CH,DL,DH         : byte   );
  34.                end;
  35.      st80    = string[80];
  36.  
  37. var cursor : integer;
  38.     regs   : regpack;
  39.  
  40. (*--------------------------------------------------------------------------*)
  41. (* Procedures to turn the cursor on and off.                                *)
  42. (*--------------------------------------------------------------------------*)
  43. procedure cursorOff;
  44. begin
  45.   regs.AX := $0300;
  46.   intr ($10,regs);
  47.   cursor := regs.CX;
  48.   regs.AX := $0100;
  49.   regs.CX := $2000;
  50.   intr ($10,regs)
  51. end;
  52.  
  53. procedure cursorOn;
  54. begin
  55.   regs.AX := $0100;
  56.   regs.CX := cursor;
  57.   intr ($10,regs)
  58. end;
  59.  
  60. (*--------------------------------------------------------------------------*)
  61. (* Procedure to read the keyboard (extended scan codes as well).            *)
  62. (*--------------------------------------------------------------------------*)
  63. procedure get (var ch:char);
  64. begin
  65.   read (kbd,ch);
  66.   if (ch = #27) and keypressed then
  67.   begin
  68.     read (kbd,ch);
  69.     case ch of
  70.       #15 : ch := ^O;     { tab backwards           }
  71.       #72 : ch := ^E;     { cursor up,    control-E }
  72.       #75 : ch := ^S;     { cursor left,  control-S }
  73.       #77 : ch := ^D;     { cursor right, control-D }
  74.       #80 : ch := ^X;     { cursor down,  control-X }
  75.       #82 : ch := ^V;     { insert                  }
  76.       #83 : ch := ^G;     { delete                  }
  77.       else ch := #00;
  78.     end;
  79.   end;
  80. end;
  81.  
  82. (*--------------------------------------------------------------------------*)
  83. (* Procedure to accept input, format (row,column,size,datatype,string,esc)  *)
  84. (*--------------------------------------------------------------------------*)
  85. procedure accept (row,col,len,datatype:integer; var temp:st80; var esc:boolean);
  86. var x   : integer;
  87.     ch  : char;
  88.     ins : boolean;
  89. procedure println;
  90. begin
  91.   cursorOff;
  92.   gotoxy (col,row);
  93.   write (temp);
  94.   clreol;
  95.   gotoxy (x,row);
  96.   cursorOn;
  97. end;
  98. procedure format;
  99. begin
  100.   if x < col + len - 1 then
  101.   begin
  102.     if ins then
  103.       temp := copy (temp,1,x - col) + ch + copy (temp,x - col + 1,col + len - x - 1)
  104.     else temp := copy (temp,1,x - col) + ch + copy (temp,x - col + 2,col + len - x);
  105.     x := x + 1;
  106.   end
  107.   else begin
  108.          if x = col + len - 1 then
  109.            x := x + 1;
  110.          temp := copy (temp,1,len - 1) + ch;
  111.        end;
  112. end;
  113. begin
  114.   esc := false;
  115.   ins := false;
  116.   x := col;
  117.   println;
  118.   repeat
  119.     get (ch);
  120.     if ch = #27 then
  121.     begin
  122.       esc := true;
  123.       temp := '';
  124.       exit;
  125.     end;
  126.     case ch of
  127.       #4  : if x < col + length (temp) then
  128.               x := x + 1;
  129.       #7  : temp := copy (temp,1,x - col) + copy (temp,x - col + 2,len);
  130.       #8  : if not (x <= col) then
  131.             begin
  132.               delete (temp,x - col,1);
  133.               x := x - 1;
  134.             end;
  135.       #9  : x := col + length (temp);
  136.       #15 : x := col;
  137.       #19 : if x > col then
  138.               x := x - 1;
  139.       #22 : ins := not (ins);
  140.       else if ch <> #13 then
  141.            case datatype of
  142.            1 : if ch in [#32..#125]
  143.                then format;
  144.            2 : if upcase (ch) in ['A','F','S','U']
  145.                then begin
  146.                       ch := upcase (ch);
  147.                       format;
  148.                     end;
  149.            end;
  150.     end;
  151.     println;
  152.   until ch in [#13];
  153. end;